home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources2 / Interp⁄Comp (.scm) / front.scm < prev    next >
Encoding:
Text File  |  1992-09-08  |  73.9 KB  |  1,920 lines  |  [TEXT/gamI]
  1.  (cf "tak" 'M68000 'VERBOSE)     -- produce compiler trace
  2. ; (cf "tak" 'M68000 'REPORT)      -- show usage of global variables
  3. ; (cf "tak" 'M68000 'PVM)         -- write PVM code on 'tak.pvm'
  4. ; (cf "tak" 'M68000 'DEBUG)       -- generate code with debugging info
  5. ; (cf "tak" 'M68000 'EXPANSION)   -- show code after source-to-source transform
  6. ; (cf "tak" 'M68000 'ASM 'STATS)  -- various back-end options
  7.  
  8. (define (cf source target-name . opts)
  9.  
  10.   (let ((module-name (file-name (file-root source)))
  11.         (info-port (if (memq 'VERBOSE opts) (current-output-port) #f))
  12.         (program 
  13.           (append (list BEGIN-sym)
  14.                   program-prefix
  15.                   (list (list **INCLUDE-sym source))
  16.                   program-suffix)))
  17.  
  18.     (let ((result (compile-program program
  19.                                    target-name
  20.                                    opts
  21.                                    module-name
  22.                                    (file-root source)
  23.                                    info-port)))
  24.  
  25.       (if (and info-port (not (eq? info-port (current-output-port))))
  26.         (close-output-port info-port))
  27.  
  28.       result)))
  29.  
  30. (define program-prefix #f)
  31. (set! program-prefix '())
  32.  
  33. (define program-suffix #f)
  34. (set! program-suffix '())
  35.  
  36. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  37. ;
  38. ; The expression compiler:
  39. ; -----------------------
  40.  
  41. ; sample use:
  42. ;
  43. ; (ce '(+ 2 3) 'M68000)  -- compile the expression (+ 2 3)
  44.  
  45. (define (ce expr target-name . opts)
  46.  
  47.   (let ((info-port (if (memq 'VERBOSE opts) (current-output-port) #f)))
  48.  
  49.     (let ((result (compile-program expr
  50.                                    target-name
  51.                                    opts
  52.                                    "#"
  53.                                    "#"
  54.                                    info-port)))
  55.  
  56.       (if (and info-port (not (eq? info-port (current-output-port))))
  57.         (close-output-port info-port))
  58.  
  59.       result)))
  60.  
  61. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  62. ;
  63. ; The program compiler:
  64. ; --------------------
  65.  
  66. (define (compile-program program target-name opts module-name dest info-port)
  67.  
  68.   (define (compiler-body)
  69.  
  70.     (scheme-global-var-set!
  71.       (scheme-global-var (string->canonical-symbol "##COMPILATION-OPTIONS"))
  72.       opts)
  73.  
  74.     (ptree.begin! info-port)
  75.     (virtual.begin!)
  76.     (select-target! target-name info-port)
  77.  
  78.     (parse-program
  79.       (list (expression->source program #f))
  80.       (make-global-environment)
  81.       (lambda (lst env)
  82.  
  83.         (let ((parsed-program
  84.                 (map (lambda (x) (normalize-parse-tree (car x) (cdr x))) lst)))
  85.  
  86.           (if (memq 'EXPANSION opts)
  87.             (let ((port (current-output-port)))
  88.               (display "Expansion:" port)
  89.               (newline port)
  90.               (let loop ((l parsed-program))
  91.                 (if (pair? l)
  92.                   (let ((ptree (car l)))
  93.                     (pp-expression (parse-tree->expression ptree) port)
  94.                     (loop (cdr l)))))
  95.               (newline port)))
  96.  
  97.           (let ((module-init-proc
  98.                   (compile-parsed-program module-name parsed-program env info-port)))
  99.  
  100.             (if (memq 'REPORT opts)
  101.               (generate-report env))
  102.  
  103.             (if (memq 'PVM opts)
  104.               (let ((pvm-port (open-output-file (string-append dest ".pvm"))))
  105.                 (virtual.dump module-init-proc pvm-port)
  106.                 (close-output-port pvm-port)))
  107.  
  108.             (target.dump module-init-proc dest opts)))))
  109.  
  110.     (unselect-target!)
  111.     (virtual.end!)
  112.     (ptree.end!)
  113.  
  114.     #t)
  115.  
  116.   (let ((successful (with-exception-handling compiler-body)))
  117.  
  118.     (if info-port
  119.       (if successful
  120.         (begin
  121.           (display "Compilation finished." info-port)
  122.           (newline info-port))
  123.         (begin
  124.           (display "Compilation terminated abnormally." info-port)
  125.           (newline info-port))))
  126.  
  127.     successful))
  128.  
  129. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  130. ;
  131. ; Report generation:
  132.  
  133. (define (generate-report env)
  134.   (let ((vars (sort-list (env-global-variables env)
  135.                          (lambda (x y)
  136.                            (string<? (symbol->string (var-name x))
  137.                                      (symbol->string (var-name y))))))
  138.         (decl (env-declarations env)))
  139.  
  140.     (define (report title pred? vars wrote-something?)
  141.       (if (pair? vars)
  142.         (let ((var (car vars)))
  143.           (if (pred? var)
  144.             (begin
  145.               (if (not wrote-something?)
  146.                 (begin
  147.                   (display " ")
  148.                   (display title)
  149.                   (newline)))
  150.               (let loop1 ((l (var-refs var)) (r? #f) (c? #f))
  151.                 (if (pair? l)
  152.                   (let* ((x (car l))
  153.                          (y (node-parent x)))
  154.                     (if (and y (app? y) (eq? x (app-oper y)))
  155.                       (loop1 (cdr l) r? #t)
  156.                       (loop1 (cdr l) #t c?)))
  157.                   (let loop2 ((l (var-sets var)) (d? #f) (a? #f))
  158.                     (if (pair? l)
  159.                       (if (set? (car l))
  160.                         (loop2 (cdr l) d? #t)
  161.                         (loop2 (cdr l) #t a?))
  162.                       (begin
  163.                         (display "  [")
  164.                         (if d? (display "D") (display " "))
  165.                         (if a? (display "A") (display " "))
  166.                         (if r? (display "R") (display " "))
  167.                         (if c? (display "C") (display " "))
  168.                         (display "] ")
  169.                         (display (var-name var)) (newline))))))
  170.               (report title pred? (cdr vars) #t))
  171.             (cons (car vars) (report title pred? (cdr vars) wrote-something?))))
  172.         (begin
  173.           (if wrote-something? (newline))
  174.           '())))
  175.  
  176.     (display "Global variable usage:") (newline)
  177.     (newline)
  178.  
  179.     (report "OTHERS"
  180.             (lambda (x) #t)
  181.             (report "EXTENDED"
  182.                     (lambda (x) (target.prim-info (var-name x)))
  183.                     (report "STANDARD"
  184.                             (lambda (x) (standard-procedure (var-name x) decl))
  185.                             vars
  186.                             #f)
  187.                     #f)
  188.             #f)))
  189.  
  190. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  191.  
  192. (define (compile-parsed-program module-name program env info-port)
  193.  
  194.   (if info-port
  195.     (display "Compiling:" info-port))
  196.  
  197.   (set! trace-indentation 0)
  198.  
  199.   (set! *bbs* (make-bbs))
  200.   (set! *global-env* env)
  201.  
  202.   (set! proc-tree '())
  203.   (set! proc-queue '())
  204.   (set! constant-vars '())
  205.   (set! known-procs '())
  206.  
  207.   (restore-context
  208.     (make-context 0 '() (list ret-var) '() (entry-interrupt) #f))
  209.  
  210.   (let* ((entry-lbl (bbs-new-lbl! *bbs*))
  211.          (body-lbl (bbs-new-lbl! *bbs*))
  212.          (frame (current-frame ret-var-set)))
  213.  
  214.     (bbs-entry-lbl-num-set! *bbs* entry-lbl)
  215.  
  216.     (set! entry-bb
  217.       (make-bb (make-LABEL-PROC entry-lbl 0 0 #f #f frame #f)
  218.                *bbs*))
  219.  
  220.     (bb-put-branch! entry-bb
  221.       (make-JUMP (make-lbl body-lbl) #f #f frame #f))
  222.  
  223.     (set! *bb*
  224.       (make-bb (make-LABEL-SIMP body-lbl frame #f)
  225.                *bbs*))
  226.  
  227.     (let loop1 ((l program))
  228.       (if (not (null? l))
  229.         (let ((node (car l)))
  230.           (if (def? node)
  231.             (let* ((var (def-var node))
  232.                    (val (global-val var)))
  233.               (if (and val (prc? val))
  234.                 (add-constant-var var
  235.                   (make-obj
  236.                     (make-proc-obj
  237.                       (symbol->string (var-name var)) ; name
  238.                       #t                 ; primitive?
  239.                       #f                 ; code
  240.                       (call-pattern val) ; call-pat
  241.                       #t                 ; side-effects?
  242.                       '()                ; strict-pat
  243.                       '(#f)))))))        ; type
  244.           (loop1 (cdr l)))))
  245.  
  246.     (let loop2 ((l program))
  247.       (if (null? l)
  248.  
  249.         (let ((ret-opnd (var->opnd ret-var)))
  250.           (seal-bb #t 'RETURN)
  251.           (dealloc-slots nb-slots)
  252.           (bb-put-branch! *bb*
  253.             (make-JUMP ret-opnd #f #f (current-frame (set-empty)) #f)))
  254.  
  255.         (let ((node (car l)))
  256.           (if (def? node)
  257.  
  258.             (begin
  259.               (gen-define (def-var node) (def-val node) info-port)
  260.               (loop2 (cdr l)))
  261.  
  262.             (if (null? (cdr l))
  263.               (gen-node node ret-var-set 'tail)
  264.               (begin
  265.                 (gen-node node ret-var-set 'need)
  266.                 (loop2 (cdr l))))))))
  267.  
  268.     (let loop ()
  269.       (if (pair? proc-queue)
  270.         (let ((x (car proc-queue)))
  271.           (set! proc-queue (cdr proc-queue))
  272.           (gen-proc (car x) (cadr x) (caddr x) info-port)
  273.           (trace-unindent info-port)
  274.           (loop))))
  275.  
  276.     (if info-port
  277.       (begin
  278.         (newline info-port)
  279.         (newline info-port)))
  280.  
  281.     (bbs-purify! *bbs*)
  282.  
  283.     (let ((proc
  284.             (make-proc-obj
  285.               (string-append "###" module-name)   ; name
  286.               #t            ; primitive?
  287.               *bbs*         ; code
  288.               '(0)          ; call-pat
  289.               #t            ; side-effects?
  290.               '()           ; strict-pat
  291.               '(#f))))      ; type
  292.  
  293.       (set! *bb* '())
  294.       (set! *bbs* '())
  295.       (set! *global-env* '())
  296.     
  297.       (set! proc-tree '())
  298.       (set! proc-queue '())
  299.       (set! constant-vars '())
  300.       (set! known-procs '())
  301.  
  302.       (clear-context)
  303.  
  304.       proc)))
  305.  
  306. (define *bb* '())
  307. (define *bbs* '())
  308. (define *global-env* '())
  309.  
  310. (define proc-tree '())
  311. (define proc-queue '())
  312. (define constant-vars '())
  313. (define known-procs '())
  314.  
  315. (define trace-indentation '())
  316.  
  317. (define (trace-indent info-port)
  318.   (set! trace-indentation (+ trace-indentation 1))
  319.   (if info-port
  320.     (begin
  321.       (newline info-port)
  322.       (let loop ((i trace-indentation))
  323.         (if (> i 0)
  324.           (begin (display "  " info-port) (loop (- i 1))))))))
  325.  
  326. (define (trace-unindent info-port)
  327.   (set! trace-indentation (- trace-indentation 1)))
  328.  
  329. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  330.  
  331. (define (gen-define var node info-port)
  332.   (if (prc? node)
  333.  
  334.     (let* ((p-bbs         *bbs*)
  335.            (p-bb          *bb*)
  336.            (p-proc-tree   proc-tree)
  337.            (p-proc-queue  proc-queue)
  338.            (p-known-procs known-procs)
  339.            (p-context     (current-context))
  340.            (bbs           (make-bbs))
  341.            (lbl1          (bbs-new-lbl! bbs)) ; arg check entry point
  342.            (lbl2          (bbs-new-lbl! bbs)) ; no arg check entry point
  343.            (context       (entry-context node '()))
  344.            (frame         (context->frame
  345.                             context
  346.                             (set-union (free-variables (prc-body node))
  347.                                        ret-var-set)))
  348.            (bb1           (make-bb
  349.                             (make-LABEL-PROC
  350.                               lbl1
  351.                               (length (prc-parms node))
  352.                               (prc-min node)
  353.                               (prc-rest node)
  354.                               #f
  355.                               frame
  356.                               (source-comment node))
  357.                             bbs))
  358.            (bb2           (make-bb
  359.                             (make-LABEL-SIMP
  360.                               lbl2
  361.                               frame
  362.                               (source-comment node))
  363.                             bbs)))
  364.  
  365.       (define (do-body)
  366.         (gen-proc node bb2 context info-port)
  367.         (let loop ()
  368.           (if (pair? proc-queue)
  369.             (let ((x (car proc-queue)))
  370.               (set! proc-queue (cdr proc-queue))
  371.               (gen-proc (car x) (cadr x) (caddr x) info-port)
  372.               (trace-unindent info-port)
  373.               (loop))))
  374.         (trace-unindent info-port)
  375.         (bbs-purify! *bbs*))
  376.  
  377.       (context-entry-bb-set! context bb1)
  378.       (bbs-entry-lbl-num-set! bbs lbl1)
  379.       (bb-put-branch! bb1
  380.         (make-JUMP (make-lbl lbl2) #f #f frame (source-comment node)))
  381.       (set! *bbs* bbs)
  382.       (set! proc-tree '())
  383.       (set! proc-queue '())
  384.       (set! known-procs '())
  385.       (if (constant-var? var)
  386.         (let-constant-var var (make-lbl lbl1)
  387.           (lambda ()
  388.             (add-known-proc lbl1 node)
  389.             (do-body)))
  390.         (do-body))
  391.       (set! *bbs* p-bbs)
  392.       (set! *bb* p-bb)
  393.       (set! proc-tree p-proc-tree)
  394.       (set! proc-queue p-proc-queue)
  395.       (set! known-procs p-known-procs)
  396.       (restore-context p-context)
  397.       (let* ((x (assq var constant-vars))
  398.              (proc (if x
  399.                      (let ((p (cdr x)))
  400.                        (proc-obj-code-set! (obj-val p) bbs)
  401.                        p)
  402.                      (make-obj
  403.                        (make-proc-obj
  404.                          (symbol->string (var-name var)) ; name
  405.                          #f                  ; primitive?
  406.                          bbs                 ; code
  407.                          (call-pattern node) ; call-pat
  408.                          #t                  ; side-effects?
  409.                          '()                 ; strict-pat
  410.                          '(#f))))))          ; type
  411.         (put-copy proc
  412.                   (make-glo (var-name var))
  413.                   #f
  414.                   ret-var-set)))
  415.  
  416.     (put-copy (gen-node node ret-var-set 'need)
  417.               (make-glo (var-name var))
  418.               #f
  419.               ret-var-set)))
  420.  
  421. (define (call-pattern node)
  422.   (make-pattern (prc-min node) (length (prc-parms node)) (prc-rest node)))
  423.  
  424. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  425. ;
  426. ; Runtime context manipulation (i.e. where the variables are, what registers
  427. ; are in use, etc.)
  428.  
  429. ; runtime context description: nb-slots = number of slots presently allocated
  430. ; for the current frame on the stack, slots = list of variables associated with
  431. ; each slot (topmost slot first), regs = list of variables contained in each
  432. ; register, closed = list of variables which are closed with respect to the
  433. ; current procedure, interrupt = what is the maximum number of PVM instructions
  434. ; that can be executed before doing an interrupt check and have interrupts been
  435. ; checked since entry to this procedure, entry-bb = the entry basic block for
  436. ; the procedure containing this context (must have a label of type PROC).
  437.  
  438. (define (make-context nb-slots slots regs closed interrupt entry-bb)
  439.   (vector nb-slots slots regs closed interrupt entry-bb))
  440.  
  441. (define (context-nb-slots x)        (vector-ref x 0))
  442. (define (context-slots x)           (vector-ref x 1))
  443. (define (context-regs x)            (vector-ref x 2))
  444. (define (context-closed x)          (vector-ref x 3))
  445. (define (context-interrupt x)       (vector-ref x 4))
  446. (define (context-entry-bb x)        (vector-ref x 5))
  447. (define (context-entry-bb-set! x y) (vector-set! x 5 y))
  448.  
  449. (define nb-slots  '())
  450. (define slots     '())
  451. (define regs      '())
  452. (define closed    '())
  453. (define interrupt '())
  454. (define entry-bb  '())
  455.  
  456. (define (restore-context context)
  457.   (set! nb-slots   (context-nb-slots context))
  458.   (set! slots      (context-slots context))
  459.   (set! regs       (context-regs context))
  460.   (set! closed     (context-closed context))
  461.   (set! interrupt  (context-interrupt context))
  462.   (set! entry-bb   (context-entry-bb context)))
  463.  
  464. (define (clear-context)
  465.   (restore-context (make-context '() '() '() '() '() '())))
  466.  
  467. (define (current-context)
  468.   (make-context nb-slots slots regs closed interrupt entry-bb))
  469.  
  470. (define (current-frame live)
  471.   (make-frame nb-slots slots regs closed live))
  472.  
  473. (define (context->frame context live)
  474.   (make-frame (context-nb-slots context)
  475.               (context-slots context)
  476.               (context-regs context)
  477.               (context-closed context)
  478.               live))
  479.  
  480. (define (make-interrupt checked? delta)
  481.   (cons checked? delta))
  482.  
  483. (define (interrupt-checked? x) (car x))
  484. (define (interrupt-delta x) (cdr x))
  485.  
  486. (define (entry-interrupt)
  487.   (make-interrupt #f (- interrupt-period interrupt-head)))
  488.  
  489. (define (return-interrupt interrupt)
  490.   (let ((delta (interrupt-delta interrupt)))
  491.     (make-interrupt (interrupt-checked? interrupt)
  492.                     (+ interrupt-head (max delta interrupt-tail)))))
  493.  
  494. (define (interrupt-merge interrupt other-interrupt)
  495.   (make-interrupt
  496.     (or (interrupt-checked? interrupt)
  497.         (interrupt-checked? other-interrupt))
  498.     (max (interrupt-delta interrupt)
  499.          (interrupt-delta other-interrupt))))
  500.  
  501. (define interrupt-period #f) ; Lmax
  502. (set! interrupt-period 90)
  503.  
  504. (define interrupt-head #f) ; E
  505. (set! interrupt-head 15)
  506.  
  507. (define interrupt-tail #f) ; R
  508. (set! interrupt-tail 15)
  509.  
  510. ; (entry-context proc closed) returns the context in existence upon entry to
  511. ; the procedure `proc'
  512.  
  513. (define (entry-context proc closed)
  514.  
  515.   (define (empty-vars-list n)
  516.     (if (> n 0)
  517.       (cons empty-var (empty-vars-list (- n 1)))
  518.       '()))
  519.  
  520.   (let* ((parms (prc-parms proc))
  521.          (pc (target.label-info (prc-min proc) (length parms) (prc-rest proc) (not (null? closed))))
  522.          (fs (pcontext-fs pc))
  523.          (slots-list (empty-vars-list fs))
  524.          (regs-list (empty-vars-list target.nb-regs)))
  525.  
  526.     (define (assign-var-to-loc var loc)
  527.       (let ((x (cond ((reg? loc)
  528.                       (let ((i (reg-num loc)))
  529.                         (if (<= i target.nb-regs)
  530.                           (nth-after regs-list i)
  531.                           (compiler-internal-error
  532.                             "entry-context, reg out of bound in back-end's pcontext"))))
  533.                      ((stk? loc)
  534.                       (let ((i (stk-num loc)))
  535.                         (if (<= i fs)
  536.                           (nth-after slots-list (- fs i))
  537.                           (compiler-internal-error
  538.                             "entry-context, stk out of bound in back-end's pcontext"))))
  539.                      (else
  540.                       (compiler-internal-error
  541.                         "entry-context, loc other than reg or stk in back-end's pcontext")))))
  542.         (if (eq? (car x) empty-var)
  543.           (set-car! x var)
  544.           (compiler-internal-error
  545.             "entry-context, duplicate location in back-end's pcontext"))))
  546.  
  547.     (let loop ((l (pcontext-map pc)))
  548.       (if (not (null? l))
  549.         (let* ((couple (car l))
  550.                (name (car couple))
  551.                (loc (cdr couple)))
  552.           (cond ((eq? name 'return)
  553.                  (assign-var-to-loc ret-var loc))
  554.                 ((eq? name 'closure-env)
  555.                  (assign-var-to-loc closure-env-var loc))
  556.                 (else
  557.                  (assign-var-to-loc (list-ref parms (- name 1)) loc)))
  558.           (loop (cdr l)))))
  559.  
  560.     (make-context fs slots-list regs-list closed (entry-interrupt) #f)))
  561.  
  562. (define (get-var opnd)
  563.   (cond ((glo? opnd)
  564.          (env-lookup-global-var *global-env* (glo-name opnd)))
  565.         ((reg? opnd)
  566.          (list-ref regs (reg-num opnd)))
  567.         ((stk? opnd)
  568.          (list-ref slots (- nb-slots (stk-num opnd))))
  569.         (else
  570.          (compiler-internal-error
  571.            "get-var, location must be global, register or stack slot"))))
  572.  
  573. (define (put-var opnd new)
  574.  
  575.   (define (put-v opnd new)
  576.     (cond ((reg? opnd)
  577.            (set! regs (replace-nth regs (reg-num opnd) new)))
  578.           ((stk? opnd)
  579.            (set! slots (replace-nth slots (- nb-slots (stk-num opnd)) new)))
  580.           (else
  581.            (compiler-internal-error
  582.              "put-var, location must be register or stack slot, for var:"
  583.              (var-name new)))))
  584.  
  585.   (if (eq? new ret-var) ; only keep one copy of return address
  586.     (let ((x (var->opnd ret-var)))
  587.       (and x (put-v x empty-var))))
  588.   (put-v opnd new))
  589.  
  590. (define (flush-regs)
  591.   (set! regs '()))
  592.  
  593. (define (push-slot)
  594.   (set! nb-slots (+ nb-slots 1))
  595.   (set! slots    (cons empty-var slots)))
  596.  
  597. (define (dealloc-slots n)
  598.   (set! nb-slots (- nb-slots n))
  599.   (set! slots    (nth-after slots n)))
  600.  
  601. (define (pop-slot)
  602.   (dealloc-slots 1))
  603.  
  604. (define (replace-nth l i v)
  605.   (if (null? l)
  606.     (if (= i 0)
  607.       (list v)
  608.       (cons empty-var (replace-nth l (- i 1) v)))
  609.     (if (= i 0)
  610.       (cons v (cdr l))
  611.       (cons (car l) (replace-nth (cdr l) (- i 1) v)))))
  612.  
  613. (define (live-vars live)
  614.   (if (not (set-empty? (set-intersection live (list->set closed))))
  615.     (set-adjoin live closure-env-var)
  616.     live))
  617.  
  618. (define (dead-slots live)
  619.   (let ((live-v (live-vars live)))
  620.     (define (loop s l i)
  621.       (cond ((null? l) (list->set (reverse s)))
  622.             ((set-member? (car l) live-v)
  623.              (loop s (cdr l) (- i 1)))
  624.             (else
  625.              (loop (cons i s) (cdr l) (- i 1)))))
  626.     (loop '() slots nb-slots)))
  627.  
  628. (define (live-slots live)
  629.   (let ((live-v (live-vars live)))
  630.     (define (loop s l i)
  631.       (cond ((null? l) (list->set (reverse s)))
  632.             ((set-member? (car l) live-v)
  633.              (loop (cons i s) (cdr l) (- i 1)))
  634.             (else
  635.              (loop s (cdr l) (- i 1)))))
  636.     (loop '() slots nb-slots)))
  637.  
  638. (define (dead-regs live)
  639.   (let ((live-v (live-vars live)))
  640.     (define (loop s l i)
  641.       (cond ((>= i target.nb-regs) (list->set (reverse s)))
  642.             ((null? l)
  643.              (loop (cons i s) l (+ i 1)))
  644.             ((and (set-member? (car l) live-v)
  645.                   (not (memq (car l) slots)))
  646.              (loop s (cdr l) (+ i 1)))
  647.             (else
  648.              (loop (cons i s) (cdr l) (+ i 1)))))
  649.     (loop '() regs 0)))
  650.  
  651. (define (live-regs live)
  652.   (let ((live-v (live-vars live)))
  653.     (define (loop s l i)
  654.       (cond ((null? l) (list->set (reverse s)))
  655.             ((and (set-member? (car l) live-v)
  656.                   (not (memq (car l) slots)))
  657.              (loop (cons i s) (cdr l) (+ i 1)))
  658.             (else
  659.              (loop s (cdr l) (+ i 1)))))
  660.     (loop '() regs 0)))
  661.  
  662. (define (lowest-dead-slot live)
  663.   (make-stk (or (lowest (dead-slots live)) (+ nb-slots 1))))
  664.  
  665. (define (highest-live-slot live)
  666.   (make-stk (or (highest (live-slots live)) 0)))
  667.  
  668. (define (lowest-dead-reg live)
  669.   (let ((x (lowest (set-remove (dead-regs live) 0))))
  670.     (if x (make-reg x) #f)))
  671.  
  672. (define (highest-dead-reg live)
  673.   (let ((x (highest (dead-regs live))))
  674.     (if x (make-reg x) #f)))
  675.  
  676. (define (highest set) ; return highest number in the set
  677.   (if (set-empty? set) #f (apply max (set->list set))))
  678.  
  679. (define (lowest set) ; return lowest number in the set
  680.   (if (set-empty? set) #f (apply min (set->list set))))
  681.  
  682. (define (above set n) ; return numbers above n in the set
  683.   (set-keep (lambda (x) (> x n)) set))
  684.   
  685. (define (below set n) ; return numbers below n in the set
  686.   (set-keep (lambda (x) (< x n)) set))
  687.   
  688. (define (var->opnd var)
  689.   (let ((x (assq var constant-vars)))
  690.     (if x
  691.       (cdr x)
  692.       (if (global? var)
  693.         (make-glo (var-name var))
  694.         (let ((n (pos-in-list var regs)))
  695.           (if n
  696.             (make-reg n)
  697.             (let ((n (pos-in-list var slots)))
  698.               (if n
  699.                 (make-stk (- nb-slots n))
  700.                 (let ((n (pos-in-list var closed)))
  701.                   (if n
  702.                     (make-clo (var->opnd closure-env-var) (+ n 1))
  703.                     (compiler-internal-error
  704.                       "var->opnd, variable is not accessible:" (var-name var))))))))))))
  705.  
  706. (define (source-comment node)
  707.   (let ((x (make-comment)))
  708.     (comment-put! x 'SOURCE (node-source node))
  709.     x))
  710.  
  711. ;------------------------------------------------------------------------------
  712.  
  713. (define (add-constant-var var opnd)
  714.   (set! constant-vars (cons (cons var opnd) constant-vars)))
  715.  
  716. (define (let-constant-var var opnd thunk)
  717.   (let* ((x (assq var constant-vars))
  718.          (temp (cdr x)))
  719.     (set-cdr! x opnd)
  720.     (thunk)
  721.     (set-cdr! x temp)))
  722.  
  723. (define (constant-var? var)
  724.   (assq var constant-vars))
  725.  
  726. (define (not-constant-var? var)
  727.   (not (constant-var? var)))
  728.  
  729. (define (add-known-proc label proc)
  730.   (set! known-procs (cons (cons label proc) known-procs)))
  731.  
  732. ;------------------------------------------------------------------------------
  733. ;
  734. ; generate code for a procedure
  735.  
  736. (define (gen-proc proc bb context info-port)
  737.   (trace-indent info-port)
  738.   (if info-port
  739.     (if (prc-name proc)
  740.       (display (prc-name proc) info-port)
  741.       (display "\"unknown\"" info-port)))
  742.   (let ((lbl (bb-lbl-num bb))
  743.         (live (set-union (free-variables (prc-body proc)) ret-var-set)))
  744.     (set! *bb* bb)
  745.     (restore-context context)
  746.     (gen-node (prc-body proc) ret-var-set 'tail)))
  747.  
  748. (define (schedule-gen-proc proc closed-list)
  749.   (let* ((lbl1 (bbs-new-lbl! *bbs*)) ; arg check entry point
  750.          (lbl2 (bbs-new-lbl! *bbs*)) ; no arg check entry point
  751.          (context (entry-context proc closed-list))
  752.          (frame (context->frame
  753.                   context
  754.                   (set-union (free-variables (prc-body proc))
  755.                              ret-var-set)))
  756.          (bb1 (make-bb
  757.                 (make-LABEL-PROC
  758.                   lbl1
  759.                   (length (prc-parms proc))
  760.                   (prc-min proc)
  761.                   (prc-rest proc)
  762.                   (not (null? closed-list))
  763.                   frame
  764.                   (source-comment proc))
  765.                 *bbs*))
  766.          (bb2 (make-bb
  767.                 (make-LABEL-SIMP
  768.                   lbl2
  769.                   frame
  770.                   (source-comment proc))
  771.                 *bbs*)))
  772.     (context-entry-bb-set! context bb1)
  773.     (bb-put-branch! bb1
  774.       (make-JUMP (make-lbl lbl2) #f #f frame (source-comment proc)))
  775.     (set! proc-tree (cons (cons lbl1 (bb-lbl-num entry-bb)) proc-tree))
  776.     (set! proc-queue (cons (list proc bb2 context) proc-queue))
  777.     (make-lbl lbl1)))
  778.  
  779. ;------------------------------------------------------------------------------
  780. ;
  781. ; generate code for an expression
  782.  
  783. (define (gen-node node live why)
  784.  
  785.   (cond ((cst? node)
  786.          (gen-return
  787.            (make-obj (cst-val node))
  788.            why
  789.            node))
  790.  
  791.         ((ref? node)
  792.          (let* ((var (ref-var node))
  793.                 (name (var-name var)))
  794.            (gen-return
  795.              (cond ((eq? why 'side)
  796.                     (make-obj undef-object))
  797.                    ((global? var)
  798.                     (let ((prim (target.prim-info* name (node-decl node))))
  799.                       (if prim (make-obj prim) (var->opnd var))))
  800.                    (else
  801.                     (var->opnd var)))
  802.              why
  803.              node)))
  804.  
  805.         ((set? node)
  806.          (let* ((src (gen-node (set-val node)
  807.                                (set-adjoin live (set-var node))
  808.                                'keep))
  809.                 (dst (var->opnd (set-var node))))
  810.            (put-copy src dst #f live)
  811.            (gen-return (make-obj undef-object) why node)))
  812.  
  813.         ((def? node)
  814.          (compiler-internal-error
  815.            "gen-node, 'def' node not at root of parse tree"))
  816.  
  817.         ((tst? node)
  818.          (gen-tst node live why))
  819.  
  820.         ((conj? node)
  821.          (gen-conj/disj node live why))
  822.  
  823.         ((disj? node)
  824.          (gen-conj/disj node live why))
  825.  
  826.         ((prc? node)
  827.          (let* ((closed (not-constant-closed-vars node))
  828.                 (closed-list (set->list closed))
  829.                 (proc-lbl (schedule-gen-proc node closed-list)))
  830.            (let ((opnd
  831.                   (if (null? closed-list)
  832.                     (begin
  833.                       (add-known-proc (lbl-num proc-lbl) node)
  834.                       proc-lbl)
  835.                     (begin
  836.                       (dealloc-slots (- nb-slots
  837.                                         (stk-num (highest-live-slot
  838.                                                    (set-union closed live)))))
  839.                       (push-slot)
  840.                       (let ((slot (make-stk nb-slots))
  841.                             (var (make-temp-var 'closure)))
  842.                         (put-var slot var)
  843.                         (bb-put-non-branch! *bb*
  844.                           (make-MAKE_CLOSURES
  845.                             (list (make-closure-parms
  846.                                     slot
  847.                                     (lbl-num proc-lbl)
  848.                                     (map var->opnd closed-list)))
  849.                             (current-frame (set-adjoin live var))
  850.                             (source-comment node)))
  851.                         slot)))))
  852.              (gen-return opnd why node))))
  853.  
  854.         ((app? node)
  855.          (gen-call node live why))
  856.  
  857.         ((fut? node)
  858.          (gen-fut node live why))
  859.  
  860.         (else
  861.          (compiler-internal-error
  862.            "gen-node, unknown parse tree node type:" node))))
  863.  
  864. (define (gen-return opnd why node)
  865.   (cond ((eq? why 'tail)
  866.          (let ((var (make-temp-var 'result)))
  867.            (put-copy opnd target.proc-result var ret-var-set)
  868.            (let ((ret-opnd (var->opnd ret-var)))
  869.              (seal-bb (intr-checks? (node-decl e live)
  870.             (source-comment node)))
  871.  
  872.         (cont true-lbl false-lbl)))))
  873.  
  874. (define (gen-tst node live why)
  875.  
  876.   (let ((pre (tst-pre node))
  877.         (con (tst-con node))
  878.         (alt (tst-alt node)))
  879.  
  880.     (predicate pre (set-union live (free-variables con) (free-variables alt))
  881.  
  882.       (lambda (true-lbl false-lbl)
  883.  
  884.         (let ((pre-context (current-context))
  885.               (true-bb (make-bb
  886.                          (make-LABEL-SIMP
  887.                            true-lbl
  888.                            (current-frame (set-union live (free-variables con)))
  889.                            (source-comment con))
  890.                          *bbs*))
  891.               (false-bb (make-bb
  892.                           (make-LABEL-SIMP
  893.                             false-lbl
  894.                             (current-frame (set-union live (free-variables alt)))
  895.                             (source-comment alt))
  896.                           *bbs*)))
  897.  
  898.           (set! *bb* true-bb)
  899.  
  900.           (let ((con-opnd (gen-node con live why)))
  901.  
  902.             (if (eq? why 'tail)
  903.  
  904.               (begin
  905.                 (restore-context pre-context)
  906.                 (set! *bb* false-bb)
  907.                 (gen-node alt live why))
  908.  
  909.               (let* ((result-var (make-temp-var 'result))
  910.                      (live-after (set-adjoin live result-var)))
  911.  
  912.                 (save-opnd-to-reg con-opnd
  913.                                   target.proc-result
  914.                                   result-var
  915.                                   live)
  916.  
  917.                 (let ((con-context (current-context))
  918.                       (con-bb *bb*))
  919.                   (restore-context pre-context)
  920.                   (set! *bb* false-bb)
  921.  
  922.                   (save-opnd-to-reg (gen-node alt live why)
  923.                                     target.proc-result
  924.                                     result-var
  925.                                     live)
  926.  
  927.                   (let ((next-lbl (bbs-new-lbl! *bbs*))
  928.                         (alt-bb *bb*))
  929.  
  930.                     (if (> (context-nb-slots con-context) nb-slots)
  931.                       (begin
  932.                         (seal-bb (intr-checks? (node-decl node)) 'INTERNAL)
  933.                         (let ((alt-context (current-context)))
  934.                           (restore-context con-context)
  935.                           (set! *bb* con-bb)
  936.                           (merge-contexts-and-seal-bb
  937.                             alt-context
  938.                             live-after
  939.                             (intr-checks? (node-decl node))
  940.                             'INTERNAL)))
  941.                       (let ((alt-context (current-context)))
  942.                         (restore-context con-context)
  943.                         (set! *bb* con-bb)
  944.                         (seal-bb (intr-checks? (node-decl node)) 'INTERNAL)
  945.                         (let ((con-context* (current-context)))
  946.                           (restore-context alt-context)
  947.                           (set! *bb* alt-bb)
  948.                           (merge-contexts-and-seal-bb
  949.                             con-context*
  950.                             live-after
  951.                             (intr-checks? (node-decl node))
  952.                             'INTERNAL))))
  953.  
  954.                     (let ((frame (current-frame live-after)))
  955.  
  956.                       (bb-put-branch! con-bb
  957.                         (make-JUMP
  958.                           (make-lbl next-lbl)
  959.                           #f
  960.                           #f
  961.                           frame
  962.                           (source-comment node)))
  963.  
  964.                       (bb-put-branch! alt-bb
  965.                         (make-JUMP
  966.                           (make-lbl next-lbl)
  967.                           #f
  968.                           #f
  969.                           frame
  970.                           (source-comment node)))
  971.  
  972.                       (set! *bb* (make-bb
  973.                                    (make-LABEL-SIMP
  974.                                      next-lbl
  975.                                      frame
  976.                                      (source-comment node))
  977.                                    *bbs*))
  978.  
  979.                       target.proc-result)))))))))))
  980.  
  981. (define (nb-args-conforms? n call-pat)
  982.   (pattern-member? n call-pat))
  983.  
  984. ; 'merge-contexts-and-seal-bb' generates code to transform the current
  985. ; context (i.e. reg and stack values and frame size) to 'other-context' only
  986. ; considering the variables in 'live'.
  987.  
  988. (define (merge-contexts-and-seal-bb other-context live checks? where)
  989.   (let ((live-v (live-vars live))
  990.         (other-nb-slots (context-nb-slots other-context))
  991.         (other-regs (context-regs other-context))
  992.         (other-slots (context-slots other-context))
  993.         (other-interrupt (context-interrupt other-context))
  994.         (other-entry-bb (context-entry-bb other-context)))
  995.  
  996.     (let loop1 ((i (- target.nb-regs 1)))
  997.       (if (>= i 0)
  998.  
  999.         (let ((other-var (reg->var other-regs i))
  1000.               (var (reg->var regs i)))
  1001.           (if (and (not (eq? var other-var)) ; if var not already there and
  1002.                    (set-member? other-var live-v)) ; must keep other-var somewhere
  1003.             (let ((r (make-reg i)))
  1004.               (put-var r empty-var)
  1005.               (if (not (or (not (set-member? var live-v))
  1006.                            (memq var regs)
  1007.                            (memq var slots)))
  1008.                 (let ((top (make-stk (+ nb-slots 1))))
  1009.                   (put-copy r top var live-v)))
  1010.               (put-copy (var->opnd other-var) r other-var live-v)))
  1011.           (loop1 (- i 1)))))
  1012.  
  1013.     (let loop2 ((i 1))
  1014.       (if (<= i other-nb-slots)
  1015.  
  1016.         (let ((other-var (stk->var other-slots i))
  1017.               (var (stk->var slots i)))
  1018.           (if (and (not (eq? var other-var)) ; if var not already there and
  1019.                    (set-member? other-var live-v)) ; must keep other-var somewhere
  1020.             (let ((s (make-stk i)))
  1021.               (if (<= i nb-slots) (put-var s empty-var))
  1022.               (if (not (or (not (set-member? var live-v))
  1023.                            (memq var regs)
  1024.                            (memq var slots)))
  1025.                 (let ((top (make-stk (+ nb-slots 1))))
  1026.                   (put-copy s top var live-v)))
  1027.               (put-copy (var->opnd other-var) s other-var live-v))
  1028.             (if (> i nb-slots)
  1029.               (let ((top (make-stk (+ nb-slots 1))))
  1030.                 (put-copy (make-obj undef-object) top empty-var live-v))))
  1031.           (loop2 (+ i 1)))))
  1032.  
  1033.     (dealloc-slots (- nb-slots other-nb-slots))
  1034.  
  1035.     (let loop3 ((i (- target.nb-regs 1)))
  1036.       (if (>= i 0)
  1037.  
  1038.         (let ((other-var (reg->var other-regs i))
  1039.               (var (reg->var regs i)))
  1040.           (if (not (eq? var other-var))
  1041.             (put-var (make-reg i) empty-var))
  1042.           (loop3 (- i 1)))))
  1043.  
  1044.     (let loop4 ((i 1))
  1045.       (if (<= i other-nb-slots)
  1046.  
  1047.         (let ((other-var (stk->var other-slots i))
  1048.               (var (stk->var slots i)))
  1049.           (if (not (eq? var other-var))
  1050.             (put-var (make-stk i) empty-var))
  1051.           (loop4 (+ i 1)))))
  1052.  
  1053.     (seal-bb checks? where)
  1054.  
  1055.     (set! interrupt (interrupt-merge interrupt other-interrupt))
  1056.  
  1057.     (if (not (eq? entry-bb other-entry-bb))
  1058.       (compiler-internal-error
  1059.         "merge-contexts-and-seal-bb, entry-bb's do not agree"))))
  1060.  
  1061. (define (seal-bb checks? where)
  1062.  
  1063.   (define (last-pair l)
  1064.     (if (pair? (cdr l)) (last-pair (cdr l)) l))
  1065.  
  1066.   (define (intr-check-at split-point)
  1067.     (let loop ((i 0) (l1 (bb-non-branch-instrs *bb*)) (l2 '()))
  1068.       (if (< i split-point)
  1069.         (loop (+ i 1) (cdr l1) (cons (car l1) l2))
  1070.         (let* ((label-instr (bb-label-instr *bb*))
  1071.                (non-branch-instrs1 (reverse l2))
  1072.                (non-branch-instrs2 l1)
  1073.                (frame (pvm-instr-frame
  1074.                         (car (last-pair (cons label-instr
  1075.                                               non-branch-instrs1)))))
  1076.                (prec-bb (make-bb label-instr *bbs*))
  1077.                (new-lbl (bbs-new-lbl! *bbs*)))
  1078.           (bb-non-branch-instrs-set! prec-bb non-branch-instrs1)
  1079.           (bb-put-branch! prec-bb
  1080.             (make-JUMP (make-lbl new-lbl) #f #t frame #f))
  1081.           (bb-label-instr-set! *bb* (make-LABEL-SIMP new-lbl frame #f))
  1082.           (bb-non-branch-instrs-set! *bb* non-branch-instrs2)
  1083.           (set! interrupt (make-interrupt #t 0))))))
  1084.  
  1085.   (define (intr-check-at-end)
  1086.     (intr-check-at (length (bb-non-branch-instrs *bb*))))
  1087.  
  1088.   (define (impose-intr-check-constraints)
  1089.     (let ((n (+ (length (bb-non-branch-instrs *bb*)) 1))
  1090.           (delta (interrupt-delta interrupt)))
  1091.       (if (> (+ delta n) interrupt-period)
  1092.         (begin
  1093.           (intr-check-at (max (- interrupt-period delta) 0))
  1094.           (impose-intr-check-constraints)))))
  1095.  
  1096.   (if checks? (impose-intr-check-constraints))
  1097.  
  1098.   (let* ((n (+ (length (bb-non-branch-instrs *bb*)) 1))
  1099.          (delta (+ (interrupt-delta interrupt) n))
  1100.          (checked? (interrupt-checked? interrupt)))
  1101.     (if (and checks?
  1102.              (case where
  1103.                ((CALL)
  1104.                 (> delta (- interrupt-period interrupt-head)))
  1105.                ((TAIL-CALL)
  1106.                 (> delta interrupt-tail))
  1107.                ((RETURN)
  1108.                 (and checked? (> delta (+ interrupt-head interrupt-tail))))
  1109.                ((INTERNAL)
  1110.                 #f)
  1111.                (else
  1112.                 (compiler-internal-error "seal-bb, unknown 'where':" where))))
  1113.       (intr-check-at-end)
  1114.       (set! interrupt (make-interrupt checked? delta)))))
  1115.  
  1116. (define (reg->var regs i)
  1117.   (cond ((null? regs)
  1118.          '())
  1119.         ((> i 0)
  1120.          (reg->var (cdr regs) (- i 1)))
  1121.         (else
  1122.          (car regs))))
  1123.  
  1124. (define (stk->var slots i)
  1125.   (let ((j (- (length slots) i)))
  1126.     (if (< j 0)
  1127.       '()
  1128.       (list-ref slots j))))
  1129.  
  1130. ;------------------------------------------------------------------------------
  1131. ;
  1132. ; generate code for a conjunction or disjunction
  1133.  
  1134. (define (gen-conj/disj node live why)
  1135.  
  1136.   (let ((pre (if (conj? node) (conj-pre node) (disj-pre node)))
  1137.         (alt (if (conj? node) (conj-alt node) (disj-alt node))))
  1138.  
  1139.     (let ((needed (set-union live (free-variables alt)))
  1140.           (bool? (boolean-value? pre))
  1141.           (predicate-var (make-temp-var 'predicate)))
  1142.  
  1143.       (define (general-predicate node live cont)
  1144.         (let* ((con-lbl (bbs-new-lbl! *bbs*))
  1145.                (alt-lbl (bbs-new-lbl! *bbs*)))
  1146.  
  1147.           (save-opnd-to-reg (gen-node pre live 'need)
  1148.                             target.proc-result
  1149.                             predicate-var
  1150.                             live)
  1151.  
  1152.           (seal-bb (intr-checks? (node-decl node)) 'INTERNAL)
  1153.  
  1154.           (bb-put-branch! *bb*
  1155.             (make-COND
  1156.               **NOT-proc-obj
  1157.               (flag-pot-fut (list target.proc-result)
  1158.                             (lambda (i) #t)
  1159.                             (node-decl node))
  1160.               alt-lbl
  1161.               con-lbl
  1162.               #f
  1163.               (current-frame (set-adjoin live predicate-var))
  1164.               (source-comment node)))
  1165.  
  1166.           (cont con-lbl alt-lbl)))
  1167.  
  1168.       (define (alternative con-lbl alt-lbl)
  1169.         (let* ((pre-context (current-context))
  1170.                (result-var (make-temp-var 'result))
  1171.                (con-live (if bool? live (set-adjoin live predicate-var)))
  1172.                (alt-live (set-union live (free-variables alt)))
  1173.                (con-bb (make-bb
  1174.                          (make-LABEL-SIMP
  1175.                            con-lbl
  1176.                            (current-frame con-live)
  1177.                            (source-comment node))
  1178.                          *bbs*))
  1179.                (alt-bb (make-bb
  1180.                          (make-LABEL-SIMP
  1181.                            alt-lbl
  1182.                            (current-frame alt-live)
  1183.                            (source-comment alt))
  1184.                          *bbs*)))
  1185.  
  1186.           (if bool?
  1187.             (begin
  1188.               (set! *bb* con-bb)
  1189.               (save-opnd-to-reg (make-obj (if (conj? node) false-object #t))
  1190.                                 target.proc-result
  1191.                                 result-var
  1192.                                 live))
  1193.             (put-var (var->opnd predicate-var) result-var))
  1194.  
  1195.           (let ((con-context (current-context)))
  1196.  
  1197.             (set! *bb* alt-bb)
  1198.  
  1199.             (restore-context pre-context)
  1200.  
  1201.             (let ((alt-opnd (gen-node alt live why)))
  1202.  
  1203.               (if (eq? why 'tail)
  1204.  
  1205.                 (begin
  1206.                   (restore-context con-context)
  1207.                   (set! *bb* con-bb)
  1208.                   (let ((ret-opnd (var->opnd ret-var))
  1209.                         (result-set (set-singleton result-var)))
  1210.                     (seal-bb (intr-checks? (node-decl node)) 'RETURN)
  1211.                     (dealloc-slots nb-slots)
  1212.                     (bb-put-branch! *bb*
  1213.                       (make-JUMP ret-opnd
  1214.                                  #f
  1215.                                  #f
  1216.                                  (current-frame result-set)
  1217.                                  (source-comment node)))))
  1218.  
  1219.                 (let ((alt-context* (current-context))
  1220.                       (alt-bb* *bb*))
  1221.  
  1222.                   (restore-context con-context)
  1223.                   (set! *bb* con-bb)
  1224.                   (seal-bb (intr-checks? (node-decl node)) 'INTERNAL)
  1225.  
  1226.                   (let ((con-context* (current-context))
  1227.                         (next-lbl (bbs-new-lbl! *bbs*)))
  1228.  
  1229.                     (restore-context alt-context*)
  1230.                     (set! *bb* alt-bb*)
  1231.  
  1232.                     (save-opnd-to-reg alt-opnd
  1233.                                       target.proc-result
  1234.                                       result-var
  1235.                                       live)
  1236.  
  1237.                     (merge-contexts-and-seal-bb
  1238.                       con-context*
  1239.                       (set-adjoin live result-var)
  1240.                       (intr-checks? (node-decl node))
  1241.                       'INTERNAL)
  1242.  
  1243.                     (let ((frame (current-frame (set-adjoin live result-var))))
  1244.  
  1245.                       (bb-put-branch! *bb*
  1246.                         (make-JUMP
  1247.                           (make-lbl next-lbl)
  1248.                           #f
  1249.                           #f
  1250.                           frame
  1251.                           (source-comment node)))
  1252.  
  1253.                       (bb-put-branch! con-bb
  1254.                         (make-JUMP
  1255.                           (make-lbl next-lbl)
  1256.                           #f
  1257.                           #f
  1258.                           frame
  1259.                           (source-comment node)))
  1260.  
  1261.                       (set! *bb* (make-bb
  1262.                                    (make-LABEL-SIMP
  1263.                                      next-lbl
  1264.                                      frame
  1265.                                      (source-comment node))
  1266.                                    *bbs*))
  1267.  
  1268.                       target.proc-result))))))))
  1269.  
  1270.       ((if bool? predicate general-predicate) pre needed
  1271.        (lambda (true-lbl false-lbl)
  1272.          (if (conj? node)
  1273.            (alternative false-lbl true-lbl)
  1274.            (alternative true-lbl false-lbl)))))))
  1275.  
  1276. ;------------------------------------------------------------------------------
  1277. ;
  1278. ; generate code for a procedure call
  1279.  
  1280. (define (gen-call node live why)
  1281.   (let* ((oper (app-oper node))
  1282.          (args (app-args node))
  1283.          (nb-args (length args)))
  1284.  
  1285.     (if (and (prc? oper) ; applying a lambda-expr is like a 'let' or 'letrec'
  1286.              (not (prc-rest oper))
  1287.              (= (length (prc-parms oper)) nb-args))
  1288.  
  1289.       (gen-let (prc-parms oper) args (prc-body oper) live why)
  1290.  
  1291.       (if (inlinable-app? node)
  1292.  
  1293.         (let ((eval-order (arg-eval-order #f args))
  1294.               (vars (map (lambda (x) (cons x #f)) args)))
  1295.  
  1296.           (let loop ((l eval-order) (liv live))
  1297.             (if (not (null? l))
  1298.  
  1299.               (let* ((needed (vals-live-vars liv (map car (cdr l))))
  1300.                      (arg (car (car l)))
  1301.                      (pos (cdr (car l)))
  1302.                      (var
  1303.                       (save-var (gen-node arg needed 'need)
  1304.                                 (make-temp-var pos)
  1305.                                 needed)))
  1306.                 (set-cdr! (assq arg vars) var)
  1307.                 (loop (cdr l) (set-adjoin liv var)))
  1308.  
  1309.               (let ((loc (if (eq? why 'side)
  1310.                            (make-reg 0)
  1311.                            (or (lowest-dead-reg live) (lowest-dead-slot live)))))
  1312.  
  1313.                 (if (and (stk? loc) (> (stk-num loc) nb-slots)) (push-slot))
  1314.  
  1315.                 (let* ((args (map var->opnd (map cdr vars)))
  1316.                        (var (make-temp-var 'result))
  1317.                        (proc (node->proc oper))
  1318.                        (strict-pat (proc-obj-strict-pat proc)))
  1319.  
  1320.                   (if (not (eq? why 'side)) (put-var loc var))
  1321.  
  1322.                   (bb-put-non-branch! *bb*
  1323.                     (make-APPLY (specialize-for-call proc (node-decl node))
  1324.                                 (flag-pot-fut
  1325.                                   args
  1326.                                   (lambda (i) (pattern-member? i strict-pat))
  1327.                                   (node-decl node))
  1328.                                 (if (eq? why 'side) #f loc)
  1329.                                 (current-frame (if (eq? why 'side) live (set-adjoin live var)))
  1330.                                 (source-comment node)))
  1331.  
  1332.                   (gen-return loc why node))))))
  1333.  
  1334.       (let* ((calling-local-proc?
  1335.                (and (ref? oper)
  1336.                     (let ((opnd (var->opnd (ref-var oper))))
  1337.                       (and (lbl? opnd)
  1338.                            (let ((x (assq (lbl-num opnd) known-procs)))
  1339.                              (and x
  1340.                                   (let ((proc (cdr x)))
  1341.                                     (and (not (prc-rest proc))
  1342.                                          (= (prc-min proc) nb-args)
  1343.                                          (= (length (prc-parms proc)) nb-args)
  1344.                                          (lbl-num opnd)))))))))
  1345.              (jstate
  1346.                (get-jump-state
  1347.                  args
  1348.                  (if calling-local-proc?
  1349.                    (target.label-info nb-args nb-args #f #f)
  1350.                    (target.jump-info nb-args))))
  1351.              (in-stk (jump-state-in-stk jstate))
  1352.              (in-reg (jump-state-in-reg jstate))
  1353.              (eval-order (arg-eval-order (if calling-local-proc? #f oper) in-reg))
  1354.              (live-after (if (eq? why 'tail) (set-remove live ret-var) live))
  1355.              (live-for-regs (args-live-vars live eval-order))
  1356.              (return-lbl (if (eq? why 'tail) #f (bbs-new-lbl! *bbs*))))
  1357.  
  1358.         ; save regs on stack if they contain values needed after the call
  1359.         (save-regs (live-regs live-after)
  1360.                    (stk-live-vars live-for-regs in-stk why))
  1361.  
  1362.         (let ((frame-start (stk-num (highest-live-slot live-after))))
  1363.  
  1364.           (let loop1 ((l in-stk) (liv live-after) (i (+ frame-start 1)))
  1365.             (if (not (null? l))
  1366.  
  1367.               ; ==== FIRST: evaluate arguments that go onto stack
  1368.  
  1369.               (let ((arg (car l))
  1370.                     (slot (make-stk i))
  1371.                     (needed (set-union (stk-live-vars liv (cdr l) why)
  1372.                                        live-for-regs)))
  1373.                 (if arg
  1374.                   (let ((var (if (and (eq? arg 'return) (eq? why 'tail))
  1375.                                ret-var
  1376.                                (make-temp-var (- frame-start i)))))
  1377.                     (save-opnd-to-stk (if (eq? arg 'return)
  1378.                                         (if (eq? why 'tail)
  1379.                                           (var->opnd ret-var)
  1380.                                           (make-lbl return-lbl))
  1381.                                         (gen-node arg needed 'need))
  1382.                                       slot
  1383.                                       var
  1384.                                       needed)
  1385.                     (loop1 (cdr l) (set-adjoin liv var) (+ i 1)))
  1386.                   (begin
  1387.                     (if (> i nb-slots)
  1388.                       (put-copy (make-obj undef-object) slot empty-var liv))
  1389.                     (loop1 (cdr l) liv (+ i 1)))))
  1390.  
  1391.               (let loop2 ((l eval-order) (liv liv) (reg-map '()) (oper-var '()))
  1392.                 (if (not (null? l))
  1393.  
  1394.                   ; ==== SECOND: evaluate operator and args that go in registers
  1395.  
  1396.                   (let* ((arg (car (car l)))
  1397.                          (pos (cdr (car l)))
  1398.                          (needed (args-live-vars liv (cdr l)))
  1399.                          (var (if (and (eq? arg 'return) (eq? why 'tail))
  1400.                                 ret-var
  1401.                                 (make-temp-var pos)))
  1402.                          (opnd (if (eq? arg 'return)
  1403.                                  (if (eq? why 'tail)
  1404.                                    (var->opnd ret-var)
  1405.                                    (make-lbl return-lbl))
  1406.                                  (gen-node arg needed 'need))))
  1407.  
  1408.                     (if (eq? pos 'operator)
  1409.  
  1410.                       ; operator
  1411.  
  1412.                       (if (and (ref? arg)
  1413.                                (not (or (obj? opnd) (lbl? opnd))))
  1414.                         (loop2 (cdr l)
  1415.                                (set-adjoin liv (ref-var arg))
  1416.                                reg-map
  1417.                                (ref-var arg))
  1418.                         (begin
  1419.                           (save-arg opnd var needed)
  1420.                           (loop2 (cdr l)
  1421.                                  (set-adjoin liv var)
  1422.                                  reg-map
  1423.                                  var)))
  1424.  
  1425.                       ; return address or argument
  1426.  
  1427.                       (let ((reg (make-reg pos)))
  1428.  
  1429.                         (if (all-args-trivial? (cdr l))
  1430.                           (save-opnd-to-reg opnd reg var needed)
  1431.                           (save-in-slot opnd var needed))
  1432.  
  1433.                         (loop2 (cdr l)
  1434.                                (set-adjoin liv var)
  1435.                                (cons (cons pos var) reg-map)
  1436.                                oper-var))))
  1437.  
  1438.                   (let loop3 ((i (- target.nb-regs 1)))
  1439.                     (if (>= i 0)
  1440.  
  1441.                       ; ==== THIRD: reload spilled registers
  1442.  
  1443.                       (let ((couple (assq i reg-map)))
  1444.                         (if couple
  1445.                           (let ((var (cdr couple)))
  1446.                             (if (not (eq? (reg->var regs i) var))
  1447.                               (save-opnd-to-reg (var->opnd var) (make-reg i) var liv))))
  1448.                         (loop3 (- i 1)))
  1449.  
  1450.                       ; ==== FOURTH: jump to procedure
  1451.  
  1452.                       (let ((opnd (if calling-local-proc?
  1453.                                     (make-lbl (+ calling-local-proc? 1))
  1454.                                     (var->opnd oper-var))))
  1455.  
  1456.                         (seal-bb (intr-checks? (node-decl node))
  1457.                                  (if return-lbl 'CALL 'TAIL-CALL))
  1458.  
  1459.                         (dealloc-slots (- nb-slots (+ frame-start (length in-stk))))
  1460.  
  1461.                         (bb-put-branch! *bb*
  1462.                           (make-JUMP
  1463.                             (car (flag-pot-fut (list opnd)
  1464.                                                (lambda (i) #t)
  1465.                                                (node-decl node)))
  1466.                             (if calling-local-proc? #f nb-args)
  1467.                             #f
  1468.                             (current-frame liv)
  1469.                             (source-comment node)))
  1470.  
  1471.                         ; ==== FIFTH: put return label if there is one
  1472.  
  1473.                         (let ((result-var (make-temp-var 'result)))
  1474.  
  1475.                           (dealloc-slots (- nb-slots frame-start))
  1476.                           (flush-regs)
  1477.                           (put-var target.proc-result result-var)
  1478.  
  1479.                           (if return-lbl
  1480.                             (begin
  1481.                               (set! interrupt (return-interrupt interrupt))
  1482.                               (set! *bb*
  1483.                                 (make-bb
  1484.                                   (make-LABEL-RETURN
  1485.                                     return-lbl
  1486.                                     #f
  1487.                                     (current-frame (set-adjoin live result-var))
  1488.                                     (source-comment node))
  1489.                                   *bbs*))))
  1490.  
  1491.                           target.proc-result))))))))))))))
  1492.  
  1493. (define (contained-reg/slot opnd)
  1494.   (cond ((reg? opnd)
  1495.          opnd)
  1496.         ((stk? opnd)
  1497.          opnd)
  1498.         ((clo? opnd)
  1499.          (contained-reg/slot (clo-base opnd)))
  1500.         (else
  1501.          #f)))
  1502.  
  1503. (define (opnd-needed opnd needed)
  1504.   (let ((x (contained-reg/slot opnd)))
  1505.     (if x
  1506.       (set-adjoin needed (get-var x))
  1507.       needed)))
  1508.  
  1509. (define (save-opnd opnd live)
  1510.   (let ((slot (lowest-dead-slot live)))
  1511.     (put-copy opnd slot (get-var opnd) live)))
  1512.  
  1513. (define (save-regs regs live)
  1514.   (for-each (lambda (i) (save-opnd (make-reg i) live)) (set->list regs)))
  1515.  
  1516. (define (save-opnd-to-reg opnd reg var live)
  1517.   (if (set-member? (reg-num reg) (live-regs live))
  1518.     (save-opnd reg (opnd-needed opnd live)))
  1519.   (put-copy opnd reg var live))
  1520.  
  1521. (define (save-opnd-to-stk opnd stk var live)
  1522.   (if (set-member? (stk-num stk) (live-slots live))
  1523.     (save-opnd stk (opnd-needed opnd live)))
  1524.   (put-copy opnd stk var live))
  1525.  
  1526. (define (all-args-trivial? l)
  1527.   (if (null? l)
  1528.     #t
  1529.     (let ((arg (car (car l))))
  1530.       (or (eq? arg 'return)
  1531.           (and (trivial? arg)
  1532.                (all-args-trivial? (cdr l)))))))
  1533.  
  1534. (define (every-trivial? l)
  1535.   (or (null? l)
  1536.       (and (trivial? (car l))
  1537.            (every-trivial? (cdr l)))))
  1538.  
  1539. (define (trivial? node)
  1540.   (or (cst? node)
  1541.       (ref? node)
  1542.       (and (set? node) (trivial? (set-val node)))
  1543.       (and (inlinable-app? node) (every-trivial? (app-args node)))))
  1544.  
  1545. (define (inlinable-app? node)
  1546.   (if (app? node)
  1547.     (let ((proc (node->proc (app-oper node))))
  1548.       (and proc
  1549.            (let ((spec (specialize-for-call proc (node-decl node))))
  1550.              (and (proc-obj-inlinable spec)
  1551.                   (nb-args-conforms? (length (app-args node))
  1552.                                      (proc-obj-call-pat spec))))))
  1553.     #f))
  1554.  
  1555. (define (boolean-value? node)
  1556.   (or (and (conj? node)
  1557.            (boolean-value? (conj-pre node))
  1558.            (boolean-value? (conj-alt node)))
  1559.       (and (disj? node)
  1560.            (boolean-value? (disj-pre node))
  1561.            (boolean-value? (disj-alt node)))
  1562.       (boolean-app? node)))
  1563.  
  1564. (define (boolean-app? node)
  1565.   (if (app? node)
  1566.     (let ((proc (node->proc (app-oper node))))
  1567.       (if proc
  1568.         (eq? (type-name (proc-obj-type proc)) 'BOOLEAN)
  1569.         #f))
  1570.     #f))
  1571.  
  1572. (define (node->proc node)
  1573.   (cond ((cst? node)
  1574.          (if (proc-obj? (cst-val node))
  1575.            (cst-val node)
  1576.            #f))
  1577.         ((ref? node)
  1578.          (if (global? (ref-var node))
  1579.            (target.prim-info* (var-name (ref-var node)) (node-decl node))
  1580.            #f))
  1581.         (else
  1582.          #f)))
  1583.  
  1584. (define (specialize-for-call proc decl)
  1585.   ((proc-obj-specialize proc) decl))
  1586.  
  1587. (define (flag-pot-fut opnds strict? decl)
  1588.  
  1589.   (define (flag opnds i)
  1590.     (if (pair? opnds)
  1591.       (let ((opnd (car opnds)))
  1592.         (cons (if (and (not (or (lbl? opnd) (obj? opnd))) (strict? i))
  1593.                 (put-pot-fut opnd)
  1594.                 opnd)
  1595.               (flag (cdr opnds) (+ i 1))))
  1596.       '()))
  1597.  
  1598.   (if (autotouch? decl)
  1599.     (flag opnds 0)
  1600.     opnds))
  1601.  
  1602. (define (get-jump-state args pc)
  1603.  
  1604.   (define (empty-node-list n)
  1605.     (if (> n 0)
  1606.       (cons #f (empty-node-list (- n 1)))
  1607.       '()))
  1608.  
  1609.   (let* ((fs (pcontext-fs pc))
  1610.          (slots-list (empty-node-list fs))
  1611.          (regs-list (empty-node-list target.nb-regs)))
  1612.  
  1613.     (define (assign-node-to-loc var loc)
  1614.       (let ((x (cond ((reg? loc)
  1615.                       (let ((i (reg-num loc)))
  1616.                         (if (<= i target.nb-regs)
  1617.                           (nth-after regs-list i)
  1618.                           (compiler-internal-error
  1619.                             "jump-state, reg out of bound in back-end's pcontext"))))
  1620.                      ((stk? loc)
  1621.                       (let ((i (stk-num loc)))
  1622.                         (if (<= i fs)
  1623.                           (nth-after slots-list (- i 1))
  1624.                           (compiler-internal-error
  1625.                             "jump-state, stk out of bound in back-end's pcontext"))))
  1626.                      (else
  1627.                       (compiler-internal-error
  1628.                         "jump-state, loc other than reg or stk in back-end's pcontext")))))
  1629.         (if (not (car x))
  1630.           (set-car! x var)
  1631.           (compiler-internal-error
  1632.             "jump-state, duplicate location in back-end's pcontext"))))
  1633.  
  1634.     (let loop ((l (pcontext-map pc)))
  1635.       (if (not (null? l))
  1636.         (let* ((couple (car l))
  1637.                (name (car couple))
  1638.                (loc (cdr couple)))
  1639.           (cond ((eq? name 'return)
  1640.                  (assign-node-to-loc 'return loc))
  1641.                 (else
  1642.                  (assign-node-to-loc (list-ref args (- name 1)) loc)))
  1643.           (loop (cdr l)))))
  1644.  
  1645.     (vector slots-list regs-list)))
  1646.  
  1647. (define (jump-state-in-stk x) (vector-ref x 0))
  1648.  
  1649. (define (jump-state-in-reg x) (vector-ref x 1))
  1650.  
  1651. (define (arg-eval-order oper nodes)
  1652.  
  1653.   (define (loop nodes pos part1 part2)
  1654.  
  1655.     (cond ((null? nodes)
  1656.            (let ((p1 (reverse part1))
  1657.                  (p2 (free-vars-order part2)))
  1658.              (cond ((not oper)
  1659.                     (append p1 p2))
  1660.                    ((trivial? oper)
  1661.                     (append p1 p2 (list (cons oper 'operator))))
  1662.                    (else
  1663.                     (append (cons (cons oper 'operator) p1) p2)))))
  1664.  
  1665.           ((not (car nodes))
  1666.            (loop (cdr nodes)
  1667.                  (+ pos 1)
  1668.                  part1
  1669.                  part2))
  1670.  
  1671.           ((or (eq? (car nodes) 'return)
  1672.                (trivial? (car nodes)))
  1673.            (loop (cdr nodes)
  1674.                  (+ pos 1)
  1675.                  part1
  1676.                  (cons (cons (car nodes) pos) part2)))
  1677.  
  1678.           (else
  1679.            (loop (cdr nodes)
  1680.                  (+ pos 1)
  1681.                  (cons (cons (car nodes) pos) part1)
  1682.                  part2))))
  1683.  
  1684.   (loop nodes 0 '() '()))
  1685.  
  1686. (define (free-vars-order l)
  1687.   (let ((bins '())
  1688.         (ordered-args '()))
  1689.  
  1690.     (define (free-v x)
  1691.       (if (eq? x 'return)
  1692.         (set-empty)
  1693.         (free-variables x)))
  1694.  
  1695.     (define (add-to-bin! x)
  1696.       (let ((y (assq x bins)))
  1697.         (if y
  1698.           (set-cdr! y (+ (cdr y) 1))
  1699.           (set! bins (cons (cons x 1) bins)))))
  1700.  
  1701.     (define (payoff-if-removed node)
  1702.       (let ((x (free-v node)))
  1703.         (let loop ((l (set->list x)) (r 0))
  1704.           (if (null? l)
  1705.             r
  1706.             (let ((y (cdr (assq (car l) bins))))
  1707.               (loop (cdr l) (+ r (quotient 1000 (* y y))))))))) ; heuristic
  1708.  
  1709.     (define (remove-free-vars! x)
  1710.       (let loop ((l (set->list x)))
  1711.         (if (not (null? l))
  1712.           (let ((y (assq (car l) bins)))
  1713.             (set-cdr! y (- (cdr y) 1))
  1714.             (loop (cdr l))))))
  1715.  
  1716.     (define (find-max-payoff l thunk)
  1717.       (if (null? l)
  1718.         (thunk '() -1)
  1719.         (find-max-payoff (cdr l)
  1720.           (lambda (best-arg best-payoff)
  1721.             (let ((payoff (payoff-if-removed (car (car l)))))
  1722.               (if (>= payoff best-payoff)
  1723.                 (thunk (car l) payoff)
  1724.                 (thunk best-arg best-payoff)))))))
  1725.  
  1726.     (define (remove x l)
  1727.       (cond ((null? l)       '())
  1728.             ((eq? x (car l)) (cdr l))
  1729.             (else            (cons (car l) (remove x (cdr l))))))
  1730.               
  1731.     (for-each (lambda (x)
  1732.                 (for-each add-to-bin! (set->list (free-v (car x)))))
  1733.               l)
  1734.  
  1735.     (let loop ((args l) (ordered-args '()))
  1736.       (if (null? args)
  1737.         (reverse ordered-args)
  1738.         (find-max-payoff args
  1739.           (lambda (best-arg best-payoff)
  1740.             (remove-free-vars! (free-v (car best-arg)))
  1741.             (loop (remove best-arg args) (cons best-arg ordered-args))))))))
  1742.  
  1743. (define (args-live-vars live order)
  1744.   (cond ((null? order)
  1745.          live)
  1746.         ((eq? (car (car order)) 'return)
  1747.          (args-live-vars (set-adjoin live ret-var)
  1748.                          (cdr order)))
  1749.         (else
  1750.          (args-live-vars (set-union live (free-variables (car (car order))))
  1751.                          (cdr order)))))
  1752.  
  1753. (define (stk-live-vars live slots why)
  1754.   (cond ((null? slots)
  1755.          live)
  1756.         ((not (car slots))
  1757.          (stk-live-vars live
  1758.                         (cdr slots)
  1759.                         why))
  1760.         ((eq? (car slots) 'return)
  1761.          (stk-live-vars (if (eq? why 'tail) (set-adjoin live ret-var) live)
  1762.                         (cdr slots)
  1763.                         why))
  1764.         (else
  1765.          (stk-live-vars (set-union live (free-variables (car slots)))
  1766.                         (cdr slots)
  1767.                         why))))
  1768.  
  1769.  
  1770. ;------------------------------------------------------------------------------
  1771. ;
  1772. ; generate code for a 'let' or 'letrec'
  1773.  
  1774. (define (gen-let vars vals node live why)
  1775.   (let ((var-val-map (pair-up vars vals))
  1776.         (var-set (list->set vars))
  1777.         (all-live (set-union live
  1778.                              (free-variables node)
  1779.                              (apply set-union (map free-variables vals)))))
  1780.  
  1781.     (define (var->val var) (cdr (assq var var-val-map)))
  1782.  
  1783.     (define (proc-var? var) (prc? (var->val var)))
  1784.  
  1785.     (define (closed-vars var const-proc-vars)
  1786.       (set-difference (not-constant-closed-vars (var->val var))
  1787.                       const-proc-vars))
  1788.  
  1789.     (define (no-closed-vars? var const-proc-vars)
  1790.       (set-empty? (closed-vars var const-proc-vars)))
  1791.  
  1792.     (define (closed-vars? var const-proc-vars)
  1793.       (not (no-closed-vars? var const-proc-vars)))
  1794.  
  1795.     (define (compute-const-proc-vars proc-vars)
  1796.       (let loop1 ((const-proc-vars proc-vars))
  1797.         (let ((new-const-proc-vars
  1798.                 (set-keep (lambda (x) (no-closed-vars? x const-proc-vars))
  1799.                           const-proc-vars)))
  1800.           (if (not (set-equal? new-const-proc-vars const-proc-vars))
  1801.             (loop1 new-const-proc-vars)
  1802.             const-proc-vars))))
  1803.  
  1804.     (let* ((proc-vars (set-keep proc-var? var-set))
  1805.            (const-proc-vars (compute-const-proc-vars proc-vars))
  1806.            (clo-vars (set-keep (lambda (x) (closed-vars? x const-proc-vars))
  1807.                                proc-vars))
  1808.            (clo-vars-list (set->list clo-vars)))
  1809.  
  1810.       (for-each
  1811.         (lambda (proc-var)
  1812.           (let ((label (schedule-gen-proc (var->val proc-var) '())))
  1813.             (add-known-proc (lbl-num label) (var->val proc-var))
  1814.             (add-constant-var proc-var label)))
  1815.         (set->list const-proc-vars))
  1816.  
  1817.       (let ((non-clo-vars-list
  1818.               (set->list
  1819.                 (set-keep (lambda (var)
  1820.                             (and (not (set-member? var const-proc-vars))
  1821.                                  (not (set-member? var clo-vars))))
  1822.                           vars)))
  1823.             (liv (set-union live
  1824.                             (apply
  1825.                               set-union
  1826.                               (map (lambda (x) (closed-vars x const-proc-vars))
  1827.                                    clo-vars-list))
  1828.                             (free-variables node))))
  1829.  
  1830.         (let loop2 ((vars* non-clo-vars-list))
  1831.           (if (not (null? vars*))
  1832.             (let* ((var (car vars*))
  1833.                    (val (var->val var))
  1834.                    (needed (vals-live-vars liv
  1835.                              (map var->val (cdr vars*)))))
  1836.               (if (var-useless? var)
  1837.                 (gen-node val needed 'side)
  1838.                 (save-val (gen-node val needed 'need) var needed))
  1839.               (loop2 (cdr vars*)))))
  1840.  
  1841.         (if (pair? clo-vars-list)
  1842.           (begin
  1843.  
  1844.             (dealloc-slots
  1845.               (- nb-slots (stk-num (highest-live-slot liv))))
  1846.  
  1847.             (let loop3 ((l clo-vars-list))
  1848.               (if (not (null? l))
  1849.                 (begin
  1850.                   (push-slot)
  1851.                   (let ((var (car l))
  1852.                         (slot (make-stk nb-slots)))
  1853.                      (put-var slot var)
  1854.                      (loop3 (cdr l))))))
  1855.  
  1856.             (bb-put-non-branch! *bb*
  1857.               (make-MAKE_CLOSURES
  1858.                 (map (lambda (var)
  1859.                        (let ((closed-list
  1860.                                (set->list (closed-vars var const-proc-vars))))
  1861.                          (if (null? closed-list)
  1862.                            (compiler-internal-error
  1863.                              "gen-let, no closed variables:" (var-name var))
  1864.                            (make-closure-parms
  1865.                              (var->opnd var)
  1866.                              (lbl-num (schedule-gen-proc
  1867.                                         (var->val var)
  1868.                                         closed-list))
  1869.                              (map var->opnd closed-list)))))
  1870.                      clo-vars-list)
  1871.                 (current-frame live)
  1872.                 (source-comment node)))))
  1873.  
  1874.         (gen-node node live why)))))
  1875.  
  1876. (define (save-arg opnd var live)
  1877.   (if (glo? opnd)
  1878.     (add-constant-var var opnd)
  1879.     (save-val opnd var live)))
  1880.  
  1881. (define (save-val opndlots) frame-start))
  1882.                             (cons ret-var (cdr regs))
  1883.                             '()
  1884.                             interrupt
  1885.                             entry-bb))
  1886.             (return-context
  1887.               (make-context frame-start
  1888.                             (nth-after slots (- nb-slots frame-start))
  1889.                             '()
  1890.                             closed
  1891.                             (return-interrupt interrupt)
  1892.                             entry-bb)))
  1893.  
  1894.         (restore-context task-context)
  1895.         (set! *bb* (make-bb
  1896.                      (make-LABEL-TASK
  1897.                        task-lbl
  1898.                        method
  1899.                        (current-frame live-starting-task)
  1900.                        (source-comment node))
  1901.                      *bbs*))
  1902.  
  1903.         (gen-node val ret-var-set 'tail)
  1904.  
  1905.         (let ((result-var (make-temp-var 'future)))
  1906.           (restore-context return-context)
  1907.           (put-var target.proc-result result-var)
  1908.  
  1909.           (set! *bb* (make-bb
  1910.                        (make-LABEL-RETURN
  1911.                          return-lbl
  1912.                          method
  1913.                          (current-frame (set-adjoin live result-var))
  1914.                          (source-comment node))
  1915.                        *bbs*))
  1916.  
  1917.           (gen-return target.proc-result why node))))))
  1918.  
  1919. ;------------------------------------------------------------------------------
  1920.